home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / programm.ing / m2posx10.zoo / m2posix.10 / src / dossyste.ipp < prev    next >
Encoding:
Modula Implementation  |  1993-12-09  |  9.3 KB  |  399 lines
  1. IMPLEMENTATION MODULE DosSystem;
  2. __IMP_SWITCHES__
  3. __DRIVER__
  4. #ifdef HM2
  5. #ifdef __LONG_WHOLE__
  6. (*$!i+: Modul muss mit $i- uebersetzt werden! *)
  7. (*$!w+: Modul muss mit $w- uebersetzt werden! *)
  8. #else
  9. (*$!i-: Modul muss mit $i+ uebersetzt werden! *)
  10. (*$!w-: Modul muss mit $w+ uebersetzt werden! *)
  11. #endif
  12. #endif
  13. (*****************************************************************************)
  14. (* 04-Dez-93, Holger Kleinschmidt                                            *)
  15. (*****************************************************************************)
  16.  
  17. VAL_INTRINSIC
  18. CAST_IMPORT
  19. OSCALL_IMPORT
  20.  
  21. FROM SYSTEM IMPORT
  22. (* TYPE *) ADDRESS,
  23. (* PROC *) ADR;
  24.  
  25. FROM PORTAB IMPORT
  26. (* CONST*) NULL,
  27. (* TYPE *) SIGNEDWORD, UNSIGNEDWORD, SIGNEDLONG, UNSIGNEDLONG, WORDSET;
  28.  
  29. FROM OSCALLS IMPORT
  30. (* PROC *) Pdomain, Supexec, Sversion;
  31.  
  32. #if (defined LPRM2)
  33. IMPORT GEMX;
  34. #elif (defined SPCM2)
  35. IMPORT GEMDOS;
  36. #elif (defined MM2)
  37. IMPORT PrgCtrl;
  38. #elif (defined HM2)
  39. IMPORT TOS;
  40. /*
  41. #elif (defined HM2_OLD)
  42. IMPORT System;
  43. */
  44. #elif (defined TDIM2)
  45. IMPORT GEMX;
  46. #elif (defined FTLM2)
  47. IMPORT LOADER;
  48. #endif
  49.  
  50.  
  51. #define PSHL 2F00H
  52. #define JSRA0 4E90H
  53. #define ADDQ4 588FH
  54. #define CALLSHELL(_CMD,_SHELL)\
  55.  SETREG(0,_CMD);SETREG(8,_SHELL);CODE(PSHL,JSRA0,ADDQ4)
  56.  
  57. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  58.  
  59. TYPE
  60.   ULongPtr = POINTER TO UNSIGNEDLONG;
  61.  
  62. TYPE
  63.   Cookie = RECORD
  64.     id  : UNSIGNEDLONG;
  65.     CASE TAG_COLON UNSIGNEDWORD OF
  66.       0: lc : UNSIGNEDLONG;
  67.      |1: s1 : WORDSET;
  68.          s2 : WORDSET;
  69.     ELSE
  70.          c1 : UNSIGNEDWORD;
  71.          c2 : UNSIGNEDWORD;
  72.     END;
  73.   END;
  74.  
  75.   CookieRange = [0..1000]; (* beliebig *)
  76.   CookiePtr   = POINTER TO ARRAY CookieRange OF Cookie;
  77.   CookiePPtr  = POINTER TO CookiePtr;
  78.  
  79.   OsPPtr = POINTER TO OsPtr;
  80.  
  81. VAR
  82.   mch       : MachineType;
  83.   cpu       : CPUType;
  84.   fpu       : FPUType;
  85.   linef     : UNSIGNEDWORD;
  86.   STARTTIME : UNSIGNEDLONG;
  87.   MiNT      : CARDINAL;
  88.   FLK       : BOOLEAN;
  89.   pcookie   : CookiePtr;
  90.   OSP       : OsPtr;
  91.   PCookies  : CookiePPtr;
  92.   Hz200     : ULongPtr;
  93.   ShellP    : ULongPtr;
  94.   Sysbase   : OsPPtr;
  95.  
  96. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  97. #ifdef HM2
  98. (*$E+*)
  99. #endif
  100. PROCEDURE getpcookies;
  101. (* Ergebnis ueber Register D0, damit die Prozedur reentrant bleibt *)
  102. BEGIN
  103.  SETREG(0, PCookies^);
  104. END getpcookies;
  105.  
  106. PROCEDURE gethz200;
  107. BEGIN
  108.  SETREG(0, Hz200^);
  109. END gethz200;
  110.  
  111. PROCEDURE getshellp;
  112. BEGIN
  113.  SETREG(0, ShellP^);
  114. END getshellp;
  115.  
  116. PROCEDURE init;
  117. (* Reentranz unwichtig *)
  118. BEGIN
  119.  OSP     := Sysbase^;
  120.  OSP     := OSP^.osBeg;
  121.  pcookie := PCookies^;
  122. END init;
  123. #ifdef HM2
  124. (*$E=*)
  125. #endif
  126. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  127.  
  128. PROCEDURE GetOsHeader ((* -- /AUS *) VAR osp : ADDRESS );
  129. BEGIN
  130.  osp := OSP;
  131. END GetOsHeader;
  132.  
  133. (*--------------------------------------------------------------------------*)
  134.  
  135. PROCEDURE Machine ( ): MachineType;
  136. BEGIN
  137.  RETURN(mch);
  138. END Machine;
  139.  
  140. (*---------------------------------------------------------------------------*)
  141.  
  142. PROCEDURE CPU ( ): CPUType;
  143. BEGIN
  144.  RETURN(cpu);
  145. END CPU;
  146.  
  147. (*---------------------------------------------------------------------------*)
  148.  
  149. PROCEDURE FPU ((* -- /AUS *) VAR info : FPUInfo );
  150. BEGIN
  151.  info.fpu   := fpu;
  152.  info.linef := linef;
  153. END FPU;
  154.  
  155. (*---------------------------------------------------------------------------*)
  156.  
  157. PROCEDURE MiNTVersion ( ): CARDINAL;
  158. BEGIN
  159.  RETURN(MiNT);
  160. END MiNTVersion;
  161.  
  162. (*---------------------------------------------------------------------------*)
  163.  
  164. PROCEDURE FileLocking ( ): BOOLEAN;
  165. BEGIN
  166.  RETURN(FLK);
  167. END FileLocking;
  168.  
  169. (*---------------------------------------------------------------------------*)
  170.  
  171. PROCEDURE ProcessDomain ((* EIN/ -- *) dom : INTEGER ): INTEGER;
  172.  
  173. VAR res : SIGNEDWORD;
  174.  
  175. BEGIN
  176.  IF MiNT > 0 THEN
  177.    RETURN(Pdomain(dom));
  178.  ELSE
  179.    RETURN(0); (* TOS-Domain *)
  180.  END;
  181. END ProcessDomain;
  182.  
  183. (*---------------------------------------------------------------------------*)
  184.  
  185. PROCEDURE DosVersion ( ): CARDINAL;
  186. BEGIN
  187.  RETURN(Sversion());
  188. END DosVersion;
  189.  
  190. (*---------------------------------------------------------------------------*)
  191.  
  192. PROCEDURE GetCookie ((* EIN/ -- *)     cookie : UNSIGNEDLONG;
  193.                      (* -- /AUS *) VAR value  : UNSIGNEDLONG ): BOOLEAN;
  194.  
  195. VAR __REG__ pc : CookiePtr;
  196.     __REG__ i  : CookieRange;
  197.  
  198. BEGIN
  199.  Supexec(getpcookies);
  200.  GETREGADR(0, pc);
  201.  value := 0;
  202.  
  203.  IF pc = NULL THEN
  204.    RETURN(FALSE);
  205.  ELSE
  206.    i := 0;
  207.    WHILE (pc^[i].id <> VAL(UNSIGNEDLONG,0)) AND (pc^[i].id <> cookie) DO
  208.      INC(i );
  209.    END;
  210.    IF pc^[i].id = cookie THEN
  211.      value := pc^[i].lc;
  212.      RETURN(TRUE);
  213.    ELSE
  214.      RETURN(FALSE);
  215.    END;
  216.  END;
  217. END GetCookie;
  218.  
  219. (*---------------------------------------------------------------------------*)
  220.  
  221. PROCEDURE ReadHz200 ( ): UNSIGNEDLONG;
  222.  
  223. VAR time : UNSIGNEDLONG;
  224.  
  225. BEGIN
  226.  Supexec(gethz200);
  227.  GETLREG(0, time);
  228.  RETURN(time);
  229. END ReadHz200;
  230.  
  231. (*---------------------------------------------------------------------------*)
  232.  
  233. PROCEDURE SysClock ( ): UNSIGNEDLONG;
  234. BEGIN
  235.  RETURN(ReadHz200() - STARTTIME);
  236. END SysClock;
  237.  
  238. (*---------------------------------------------------------------------------*)
  239.  
  240. PROCEDURE ShellInstalled ( ): Shell;
  241.  
  242. CONST GulamMAGIC = 00420135H;
  243.       XBRAID     = 58425241H; (* 'XBRA' *)
  244.       MasterID   = 4D415354H; (* 'MAST' *)
  245.       MupfelID   = 4D555046H; (* 'MUPF' *)
  246.       GeminiID   = 474D4E49H; (* 'GMNI' *)
  247.  
  248. TYPE xbraidp = POINTER TO ARRAY[0..1] OF UNSIGNEDLONG;
  249.      magicp  = ULongPtr;
  250.  
  251. VAR __REG__ xbraid : xbraidp;
  252.             magic  : magicp;
  253.             shell  : UNSIGNEDLONG;
  254.  
  255. BEGIN
  256.  Supexec(getshellp);
  257.  GETLREG(0, shell);
  258.  
  259.  IF shell = VAL(UNSIGNEDLONG,0) THEN
  260.    RETURN(None);
  261.  END;
  262.  xbraid := CAST(xbraidp,shell - VAL(UNSIGNEDLONG,12));
  263.  IF xbraid^[0] = XBRAID THEN
  264.    IF xbraid^[1] = MupfelID THEN
  265.      RETURN(Mupfel);
  266.    ELSIF xbraid^[1] = GeminiID  THEN
  267.      RETURN(Gemini);
  268.    ELSIF xbraid^[1] = MasterID THEN
  269.      RETURN(Master);
  270.    END;
  271.  END;
  272.  magic := CAST(magicp,shell - VAL(UNSIGNEDLONG,10));
  273.  IF magic^ = GulamMAGIC THEN
  274.    RETURN(Gulam);
  275.  END;
  276.  RETURN(Unknown);
  277. END ShellInstalled;
  278.  
  279. (*---------------------------------------------------------------------------*)
  280.  
  281. PROCEDURE DosPid ((* EIN/ -- *) bp : ADDRESS ): INTEGER;
  282. BEGIN
  283.  RETURN(INT((CAST(UNSIGNEDLONG,bp) DIV LC(256)) MOD LC(32768)));
  284. END DosPid;
  285.  
  286. (*---------------------------------------------------------------------------*)
  287.  
  288. PROCEDURE CallShell ((* EIN/ -- *) VAR cmd : ARRAY OF CHAR ): INTEGER;
  289.  
  290. VAR retCode : SIGNEDWORD;
  291.     shell   : UNSIGNEDLONG;
  292.  
  293. BEGIN
  294.  Supexec(getshellp);
  295.  GETLREG(0, shell);
  296.  IF shell = VAL(UNSIGNEDLONG,0) THEN
  297.    RETURN(-1);
  298.  ELSE
  299.    cmd[HIGH(cmd)] := 0C;
  300.    CALLSHELL(ADR(cmd), shell);
  301.    GETSWREG(0,retCode);
  302.    RETURN(INT(retCode));
  303.  END;
  304. END CallShell;
  305.  
  306. (*===========================================================================*)
  307.  
  308. CONST
  309.   MiNTCk = 4D694E54H; (* "MiNT" *)
  310.   FLKCk  = 5F464C4BH; (* "_FLK" *)
  311.   MCHCk  = 5F4D4348H; (* "_MCH" *)
  312.   CPUCk  = 5F435055H; (* "_CPU" *)
  313.   FPUCk  = 5F465055H; (* "_FPU" *)
  314.  
  315. VAR
  316.   bptr : BasePPtr;
  317.   res  : INTEGER;
  318.   vers : UNSIGNEDLONG;
  319.   i    : CookieRange;
  320.  
  321. BEGIN (* DosSystem *)
  322.  Sysbase  := CAST(OsPPtr,VAL(UNSIGNEDLONG,4F2H));
  323.  PCookies := CAST(CookiePPtr,VAL(UNSIGNEDLONG,5A0H));
  324.  Hz200    := CAST(ULongPtr,VAL(UNSIGNEDLONG,4BAH));
  325.  ShellP   := CAST(ULongPtr,VAL(UNSIGNEDLONG,4F6H));
  326.  
  327.  STARTTIME := ReadHz200();
  328.  
  329.  Supexec(init); (* OSP und pcookie setzen *)
  330.  
  331. #if (defined HM2)
  332.  BASEP := BasePtr(TOS.BasePage);
  333. #elif (defined LPRM2)
  334.  BASEP := VAL(BasePtr,GEMX.BasePagePtr);
  335. #elif (defined SPCM2)
  336.  BASEP := VAL(BasePtr,GEMDOS.BasePagePtr);
  337. #elif (defined MM2)
  338.  PrgCtrl.GetBasePageAddr(BASEP);
  339. #elif (defined TDIM2)
  340.  BASEP := BasePtr(GEMX.BasePageAddress);
  341. #elif (defined FTLM2)
  342.  BASEP := BasePtr(LOADER.ProgPrefixAddress);
  343. #else
  344.  IF VAL(CARDINAL,OSP^.osEntry) >= 0102H THEN
  345.    bptr := OSP^.pRun; (* erst ab Blitter-TOS 1.02 *)
  346.  ELSIF CAST(UNSIGNEDWORD,OSP^.osConf) DIV 2 = 4 THEN
  347.    (* Spanisches TOS 1.0 *)
  348.    bptr := CAST(BasePPtr,VAL(UNSIGNEDLONG,873CH));
  349.  ELSE
  350.    bptr := CAST(BasePPtr,VAL(UNSIGNEDLONG,602CH));
  351.  END;
  352.  BASEP := bptr^;
  353. #endif
  354.  
  355.  (* Die folgenden Cookies werden nur waehrend der Initialisierung getestet,
  356.   * da sich deren Inhalt nicht waehrend des Programmlaufs aendert.
  357.   * (Bei _FLK bin ich mir allerdings nicht ganz sicher.)
  358.   *)
  359.  MiNT  := 0;
  360.  mch   := atariST;
  361.  cpu   := CPU68000;
  362.  fpu   := FPUType{};
  363.  linef := 0;
  364.  FLK   := FALSE;
  365.  IF pcookie <> NULL THEN
  366.    i := 0;
  367.    WHILE pcookie^[i].id <> LC(0) DO
  368.      WITH pcookie^[i] DO
  369.        IF id = MiNTCk THEN
  370.          MiNT := VAL(CARDINAL,c2);
  371.          res  := Pdomain(1);
  372.        ELSIF id = FLKCk THEN
  373.          FLK := TRUE;
  374.        ELSIF id = MCHCk THEN
  375.          IF c1 <= 3 THEN
  376.            mch := VAL(MachineType,c1);
  377.          ELSE
  378.            mch := atari;
  379.          END;
  380.        ELSIF id = CPUCk THEN
  381.          IF c2 <= 40 THEN
  382.            cpu := VAL(CPUType,c2 DIV 10);
  383.          ELSE
  384.            cpu := CPU68XXX;
  385.          END;
  386.        ELSIF id = FPUCk THEN
  387. #ifdef HM2
  388.          fpu   := CAST(FPUType,CHR(c1));
  389. #else
  390.          fpu   := CAST(FPUType,c1);
  391. #endif
  392.          linef := c2;
  393.        END;
  394.      END;
  395.      INC(i);
  396.    END;
  397.  END;
  398. END DosSystem.
  399.